Personal Computer World 2006 May/PCWMAY06.iso/Software/Resources/PaperCut Quota 6.1/pc-setup.exe/{app}/create-virtual-dir.vbs

Text File | 2006-01-11 | 6KB | 202 lines

Option Explicit

On Error Resume Next


Dim oArgs
Set oArgs = WScript.Arguments
If oArgs.Count <> 2 Then
    ErrorExit "Require the 'virtual-dir-name' and 'path' parameters"
End If

Dim sComputer, sVirtualDir, sPath
sComputer = "localhost"
sVirtualDir = oArgs(0)
sPath = oArgs(1)

'A quick check to set our language
Dim WshShell
Dim sLanguage
sLanguage = "eng"
Set WshShell = WScript.CreateObject("WScript.Shell")
sLanguage = WshShell.RegRead("HKLM\Software\" & sVirtualDir & "\Language")
If Err.Number <> 0 Then
    DebugLog "Error reading langauge registry key: " & Err.Description
    Err.Clear
    sLanguage = "eng"
End If

' Define translated error messages
Dim sMSG_IIS_NOT_INSTALLED, sMSG_HOW_TO_SETUP
sMSG_IIS_NOT_INSTALLED  = "The Microsoft IIS web server is not installed on this machine."
sMSG_HOW_TO_SETUP       = "If you would like to use the Web Tools, please follow the setup instructions in the user guide."

If sLanguage = "deu" Then
    sMSG_IIS_NOT_INSTALLED  = "Microsoft Internet Information Services (IIS) sind auf diesem Computer nicht installiert."
    sMSG_HOW_TO_SETUP       = "Wenn Sie die Web Tools einsetzen m÷chten, lesen Sie die Instruktionen im Benutzerhandbuch."
End If


DebugLog "Get handle to IIS service"
Dim oWebSvc
Set oWebSvc = GetObject("IIS://" & sComputer & "/W3SVC")
If Err.Number <> 0 Then
    ErrorExit sMSG_IIS_NOT_INSTALLED
End If


Dim oRoot
DebugLog "Get handle to root of default website"
Set oRoot = GetObject("IIS://" & sComputer & "/W3SVC/1/Root")
If Err.Number <> 0 Then
    ErrorExit "Unable to connect to configure the default web site."
End If


Dim oVDir
DebugLog "Check if virtual directory already exists"
Set oVDir = GetObject("IIS://" & sComputer & "/W3SVC/1/Root/" & sVirtualDir)
If Err.Number = 0 Then
    ' The virtual dir already exists
    DebugLog "Virtual directory '" & sVirtualDir & "' already exists."
    WScript.Quit 0
End If
Err.Clear
Set oVDir = Nothing

DebugLog "Create new virtual directory"
Set oVDir = oRoot.Create("IIsWebVirtualDir", sVirtualDir)
If Err.Number <> 0 Then
    DebugLog Err.Number & " - " & Err.Description
    ErrorExit "Unable to create the Web Tools virtual directory."
End If

oVDir.AccessRead = true
oVDir.Path = sPath
If Err.Number <> 0 Then
    ErrorExit "Unable to set virtual directory path: " & sPath & "."
End If

' Save the info
oVDir.SetInfo
If Err.Number <> 0 Then
    ErrorExit "Unable to save changes to IIS virtual directory."
End If

' Create the application
oVDir.AppCreate2(2) ' (0=Low, 1=High, 2=Medium)
If Err.Number <> 0 Then
    ErrorExit "Unable to create web application."
End If

oVDir.AppFriendlyName = sVirtualDir
' Allow scripts to run
oVDir.AccessScript = true
oVDir.SetInfo
If Err.Number <> 0 Then
    ErrorExit "Unable to save changes to IIS application."
End If

' Setup virtual directory settings.  Some of these are defaults, but we set them anyway because they are modified by
' some software (e.g. the lock-down tool).
DebugLog "Setup virtual directory settings"

' Disable anonymous access
SetIISSetting sComputer, "W3SVC/1/Root/" & sVirtualDir, "AuthFlags", "4"

' Enable session state
SetIISSetting sComputer, "W3SVC/1/Root/" & sVirtualDir, "AspAllowSessionState", "True"

' Enable parent paths
SetIISSetting sComputer, "W3SVC/1/Root/" & sVirtualDir, "AspEnableParentPaths", "True"

' Set ASP buffering on
SetIISSetting sComputer, "W3SVC/1/Root/" & sVirtualDir, "AspBufferingOn", "True"

' Successfully installed
WScript.Quit 0



' Displays a message to the user then exits with error code.
Sub ErrorExit(sMsg)
    On Error Resume Next
    Dim sFullMsg

    sFullMsg = sMsg & vbCrLf & vbCrLf & sMSG_HOW_TO_SETUP

    WScript.Echo sFullMsg
    WScript.Quit 1
End Sub

Sub DebugLog(sMsg)
    'WScript.Echo sMsg
End Sub

' Adapted from adsutil.vbs
Function SetIISSetting(sMachine, sRootPath, sSetting, vValue)
    'On Error Resume Next
    Dim sFullPath
    sFullPath = "IIS://" & sMachine & "/" & sRootPath

    Dim oIISPath
    Set oIISPath = GetObject(sFullPath)
    DebugLog "Getting path: " & sFullPath
    If Err.Number <> 0 Then
        ErrorExit "Unable to get IIS path '" & sRootPath & "'"
    End If

    Dim oSchema
    Set oSchema = GetObject("IIS://" & sMachine & "/Schema/" & sSetting)
    If Err.Number <> 0 Then
        ErrorExit "Unable to get schema for property '" & sSetting & "'"
    End If

    Dim sDataType
    sDataType = Trim(UCase(oSchema.Syntax))
    DebugLog "Data type: " & sDataType

    Select Case (sDataType)

        Case "STRING"
            DebugLog "Set string: " & sSetting & " = " & vValue
            oIISPath.Put sSetting, vValue

        Case "EXPANDSZ"
            DebugLog "Set expandsz " & sSetting & " = " & vValue
            oIISPath.Put sSetting, vValue

        Case "INTEGER"
            DebugLog "Set integer " & sSetting & " = " & vValue
            ' Added to convert hex values to integers

            If (UCase(Left(vValue, 2))) = "0X" Then
                ValueData = "&h" & Right(vValue, Len(vValue) - 2)
            End If

            vValue = CLng(vValue)
            oIISPath.Put sSetting, vValue

        Case "BOOLEAN"
            DebugLog "Set boolean " & sSetting & " = " & vValue
            vValue = CBool(vValue)
            oIISPath.Put sSetting, vValue

        Case "LIST"
            ' Not implemented
            DebugLog "Setting value not supported for datatype: " & oSchema.Syntax

        Case Else
            DebugLog "Unknown data type in schema: " & oSchema.Syntax

    End Select

    ' Save the setting
    oIISPath.Setinfo
    If Err.Number <> 0 Then
        ErrorExit "Unable to save setting: " & sSetting
    End If

End Function